perm filename RESTS.F4[MSS,LCS] blob
sn#174111 filedate 1975-08-18 generic text, type T, neo UTF8
00100 SUBROUTINE RESTS
00200 COMMON/STF/RSTFAC(-3/4),RSTJ2 /XXX/LK,LP,JY
00300 COMMON/XRN/RN(2000),XN(2000)
00400 COMMON RS,JA,REST,J2,RQ(18),JX,JR,LX,RDIS
00500 COMMON/POSI/STFF(-3/4),JJ2,PQ/PTR/PWDS(250),L,LL,I,IX
00600 EQUIVALENCE (RQ(10),XLFT),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
00700 C RQ(3) IS R5 ETC.
00800 REST=0
00900 JA=0
01100 K=LX
01200 5 JL=PWDS(K)
01300 R=RN(JL+1)
01400 IF(R.NE.8)GO TO 232
01500 XLFT=RN(JL+3)
01600 GO TO 231
01700 232 IF(R.NE.1)GO TO 8
01800 4 IF(JA.EQ.0)JA=-1
01900 IF(JA.LE.-2)JA=-JA
02000 IF(JA.EQ.1)JA=-JA
02050 GO TO 231
02100 8 IF(R.NE.2)GO TO 231
02200 IF(RN(JL).LT.6)GO TO 4
02300 C FOUND A WHOLE REST MEAS.
02400 IF(REST.NE.0)GO TO 6
02500 IF(JA)JA=1
02600 C RESTS START AFTER NOTES
02700 IF(JA.EQ.0)JA=-2
02750 IF(JA.GE.2)JA=-3
02800 JR=JL+8
02900 C POINTER TO REST NUM.
03000 RN(JR-1)=RN(JR-1)*.6
03100 C REDUCE SIZE OF REST'S TIME SO IT WILL TAKE LESS SPACE.
03200 6 REST=REST+1
03300 RN(JR)=REST
03400 IF(JA.GE.2)JA=-3
03410 JL=K+2
03455 IF(JL.GE.L)RETURN
03500 LB=PWDS(JL)
03600 IF(RN(LB+1).NE.2)GO TO 233
03700 C NEXT IS TO COMBINE MEASURES OF REST
03800 IF(RN(LB).LT.6)GO TO 233
03900 C SKIP NON-WHOLE RESTS
04000 N=PWDS(K+1)
04100 IF(RN(N+1).NE.4)GO TO 233
04200 C IS REST FOLLOWED BY A BAR?
04300 CCC RN(LB+1)=0
04400 C SO IT WON'T BE FOUND NEXT TIME AROUND.
04500 RN(LB+3)=-99
04600 C MOVE IT FAR LET
04700 CCC LB=PWDS(K+1)
04800 RN(N+3)=-99
04900 C MOVES PPEV. BAR ALSO
05000 K=JL
05100 GO TO 5
05200
05300 233 REST=0
05400 231 K=K+1
05500 IF(K.LT.L)GO TO 5
05600 END
05700
05800 SUBROUTINE DELE
05900 COMMON/XRN/RN(2000),XN(2000)
06000 COMMON/STF/RSTFAC(-3/4),RSTJ2 /XXX/LK,LP,JY
06100 COMMON RS,JA,REST,J2,RQ(18),JX,JR,LX,RDIS
06200 COMMON/POSI/STFF(-3/4),JJ2,PQ/PTR/PWDS(250),L,LL,I,IX
06300 EQUIVALENCE (RQ(10),XLFT),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
06400 C NEXT DELETES UNWANTED ITEMS
06500 K=LX
06510 CC RN(IFIX(PWDS(L))+3)=200
06600 1 J=PWDS(K)
06700 RZ=RN(J+3)
06750 R5=RN(J+1)
06800 IF(R5.NE.5)GO TO 7
06900 C IS IT A SLUR?
07000 IF(RN(J+6).GT.200)RN(J+6)=199.99
07100 C .LT. XLFT IS OK FOR SLUR, BUT RT. SIDE MUST BE .LE. 200
07200 GO TO 2
07210 7 IF(R5.NE.3)GO TO 9
07220 IF(RN(J).LT.3)GO TO 9
07230 C WDCNT TOO SMALL
07240 IF(RN(J+5).EQ.4)GO TO 8
07250 C DELETES CURVED BRACKET
07300 9 IF(RZ.GE.XLFT)GO TO 2
07400 8 N=PWDS(K+1)-J
07500 DO 3 M=J,IFIX(PWDS(L))
07600 3 RN(M)=RN(M+N)
07700 RZ=N
07800 DO 4 M=K+1,L-1
07900 4 PWDS(M)=PWDS(M+1)-RZ
07910 C SHIFTS PWDS BACK A NOTCH
08000 L=L-1
08200 CC LK=LK-N
08275 C POINTS TO LAST SIGNIFICANT ITEM.
08400 CCC JY=LK
08500 C SHOULD THESE EVER BE DIFFERENT?????
08510 IF(L-1.GT.K)GO TO 1
08520 LK=PWDS(L)
08540 LP=LK
08600 RETURN
08700
08800 2 IF(RZ.GE.200)RN(J+3)=199.99
08900 C NOTHING CAN START PAST 200.
09000 K=K+1
09100 IF(K.LT.L)GO TO 1
09200 END
09300
09400 CC THESE ARE NOW IN PTMOVF.FAI FUNCTION R4567(R)
09500 CC R4567=0
09600 CC IF(R.LT.4)GO TO 1
09700 CC IF(R.LE.7)RETURN
09800 CC1 R4567=-1
09900 CC END
10000
12800 CC FUNCTION RCLEF(R)
12900 CC DIMENSION R(1)
13000 CC RCLEF=0
13100 CC IF(R(2).NE.3)RETURN
13150 C IS IT A 'CLEF'?
13200 CC IF(R(1).LT.3)RETURN
13250 C IS THE WDCNT BIG ENOUGH?
13300 CC IF(R(6).LE.3)RETURN
13400 C FINDS ONLY 'REAL' CLEFS IN CODE NUM.3
13500 CC RCLEF=-1
13600 CC END
13700
13800 SUBROUTINE REST2(KA,KB,JRH,KP,XWDS)
13900 COMMON/XRN/RN(2000),XN(2000)
14000 COMMON RS,JA,REST,J2,RQ(18),JX,JR,LX,RDIS
14100 COMMON/POSI/STFF(-3/4),JJ2,PQ/PTR/PWDS(250),L,LL,I,IX
14200 DIMENSION XWDS(1)
14400 1 DO 6 N=LX,L
14500 LL=PWDS(N)
14600 IF(RN(LL+1).NE.2)GO TO 6
14700 C NEXT PUTS IT ON PREV. LINE.
14800 REST=RN(LL+8)
14900 GO TO 4
15000 6 CONTINUE
15100
15200 C THIS LINE ALL RESTS
15300 4 DO 3 K=KB-1,1,-1
15400 LA=XWDS(K)
15500 IF(XN(LA+1).NE.2)GO TO 3
15550 IF(JRH.EQ.-2)GO TO 7
15575 C JUMP IF PREV. STAFF WAS ALL RESTS.
15600 XN(LA+8)=XN(LA+8)+REST
15800 IF(JA.NE.-2)GO TO 5
15900 LX=KA
16000 C DELETE THIS STAFF
16100 L=KB
16200 JA=JHR
16300 C SO IT THINKS IT JUST FINISHED THE PREVIOUS LINE.
16500 RETURN
16600 3 CONTINUE
16700 RETURN
16800
16900 5 DO 2 K=N+2,L
17000 LL=PWDS(K)
17100 IF(RN(LL+1).GT.2)GO TO 2
17110 IF(RN(LL+3).EQ.-99.)GO TO 2
17120 C SKIP IF MORE RESTS TO DELETE
17200 M=PWDS(N)+3
17210 LA=LL+3
17220 RZ=RN(M)
17225 RX=RN(LA)
17230 KL=K
17300 13 RN(LA)=RZ
17310 KL=KL+1
17320 LA=PWDS(KL)+3
17330 RY=RN(LA)-RX
17340 IF(RY.GT.1)GO TO 14
17345 C TO PICK NEARBY ITEMS
17350 RZ=RZ+RY
17360 GO TO 13
17400 14 RN(M)=-99
17410 12 N=N+1
17420 M=PWDS(N)+3
17430 RZ=RN(M)
17440 IF(RZ.EQ.-99.)GO TO 12
17450 C HAS IT ALREADY BEEN CHANGED?
17500 RN(M)=-99
17600 RETURN
17700 2 CONTINUE
17800 C WILL DELETE REST AND BAR. MOVE NOTE TO REST POS.
17900 RETURN
18000
18100 7 RS=RS+1
18110 DO 11 KL=LX-1,1,-1
18120 C TO FIND START OF PREV. STAFF
18130 LA=XWDS(KL)
18135 IF(XN(LA+1).EQ.2)RN(LL+8)=REST+XN(LA+8)
18137 C COMBINES REST FROM PREV. LINE WITH 1ST OF THIS LINE.
18140 11 IF(XN(LA+2).GT.RS)GO TO 10
18145 KL=0
18150 10 KL=KL+1
18200 CC RZ=PWDS(LX)-PWDS(KL)
18202 RZ=XWDS(LX)-XWDS(KL)
18210 C DIFFERENCE IN ITEMS ON THIS AND PREV. STAFF.
18300 KZ=KL
18400 DO 8 K=LX,L
18500 PWDS(KZ)=PWDS(K)-RZ
18600 KZ=KZ+1
18700 N=PWDS(K)
18800 8 RN(N+2)=RS
18900 C RESET STAFF NUM.
19000
19100 N=PWDS(KL)
19200 KP=PWDS(KZ-1)
19300 KZ=RZ
19400 DO 9 K=N,KP
19500 9 RN(K)=RN(K+KZ)
19600 CCC LX=KL+L-LX
19700 CCC KA=LX
19710 CCC L=LX
19720 L=KL+L-LX
19730 LX=KL
19740 KB=0
19800 C SO IT WILL GO THE RIGHT PLACE IN PARTS.
19850 CCC KP=KP-RZ
19900 END